home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / shellMode.tcl < prev    next >
Encoding:
Text File  |  2001-01-25  |  22.4 KB  |  838 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  # 
  4.  #  FILE: "shellMode.tcl"
  5.  #                                last update: 01/25/2001 {17:00:45 PM} 
  6.  #  Author: Vince Darley, Pete Keleher
  7.  #  E-mail: <vince@santafe.edu>
  8.  #    mail: 317 Paseo de Peralta
  9.  #          Santa Fe, NM 87501, USA
  10.  #     www: <http://www.santafe.edu/~vince/>
  11.  #  
  12.  # Some Copyright (c) 1997-2000  Vince Darley, all rights reserved
  13.  # Some copyright Pete Keleher.
  14.  # 
  15.  #  Description: 
  16.  # 
  17.  # General purpose shell routines for Alpha.  Two and a half shells
  18.  # are provided by default: the Alpha Tcl shell, the MPW toolserver
  19.  # shell and half of the comet shell (whatever that is).
  20.  # 
  21.  # A separate package 'remotetclshell' allows Alpha to act as a console
  22.  # for a separately running Wish.
  23.  # ###################################################################
  24.  ##
  25.  
  26. alpha::mode Shel 1.8.5 dummyShel [list "\\*tcl sh*"] {
  27.     tclMenu alphaDeveloperMenu
  28. } {
  29.     addMode MPW {} [list "*Toolserver shell*"] {}
  30.     # we use our own version since Alpha doesn't quite change mode
  31.     # to Shel correctly (not sure what it does wrong).
  32.     if {[llength [info commands shell]]} {rename shell {}}
  33.     # we do this ourselves.  this way we don't need a special hack
  34.     # in 'openHook'
  35.     if {[llength [info commands toolserverShell]]} {rename toolserverShell {}}
  36. } help {
  37.     file "Shells"
  38. }
  39.  
  40. set Shel::startPrompt "«"
  41. set Shel::endPrompt "»"
  42.  
  43. newPref v wordBreak "\(\\\$\)?\[a-zA-Z0-9_.${Shel::endPrompt}\]+" Shel
  44. newPref f wordWrap {0} Shel
  45. newPref f perlCallUnixLike {0} Shel
  46. newPref v wordBreakPreface "\[^a-zA-Z0-9_\\$${Shel::startPrompt}\]" Shel
  47. newPref f autoMark 0 Shel
  48. newPref f tcl_interactive 1 Shel
  49.  
  50. set invisibleModeVars(tcl_interactive) 1
  51. set Shel::endPara "^${Shel::startPrompt}.*$"
  52. set Shel::startPara "^${Shel::startPrompt}.*$"
  53. regModeKeywords -m ${Shel::startPrompt} Shel {}
  54.  
  55. ensureset Shel::histnum 0
  56.  
  57. Bind '\r' Shel::carriageReturn "Shel"
  58. Bind '\r' Shel::carriageReturn "MPW"
  59. Bind '\t' bind::Completion Shel
  60. Bind '\r' <o> Shel::newPrompt "Shel"
  61.  
  62. Bind up <z> Shel::prevHist Shel
  63. Bind down <z> Shel::nextHist Shel
  64.  
  65. Bind 'a' <z> Shel::Bol Shel
  66. Bind up Shel::up Shel
  67. Bind down Shel::down Shel
  68.  
  69. Bind 'u' <z> Shel::killLine Shel
  70.  
  71. proc dummyShel {} {}
  72.  
  73. ensureset otherDirs {}
  74.  
  75. proc Shel::OptionTitlebar {} {
  76.     regsub -all "\n *" [history] "\} \{" h
  77.     set h "\{[string trim $h]\}"
  78. }
  79.  
  80. proc Shel::OptionTitlebarSelect {item} {
  81.     insertText [string range $item [expr 2+[string first " " $item]] end]
  82.     Shel::carriageReturn
  83. }
  84.  
  85. proc Shel::DblClick {args} { eval Tcl::DblClick $args }
  86.  
  87. ## 
  88.  # -------------------------------------------------------------------------
  89.  # 
  90.  # "Shel::carriageReturn" --
  91.  # 
  92.  #  Rewritten to avoid need for global _text _return variables
  93.  # -------------------------------------------------------------------------
  94.  ##
  95. proc Shel::carriageReturn {} {
  96.     global mode histnum Shel::Type Shel::endPrompt
  97.     set pos [getPos]
  98.  
  99.     if {![catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] && $res} {
  100.     gotoMatch; return;
  101.     }
  102.     set ind [string first ${Shel::endPrompt} [getText [lineStart $pos] $pos]]
  103.     if {$ind < 0} {
  104.     insertText "\r"
  105.     return
  106.     }
  107.     endOfLine
  108.     set fileName [win::CurrentTail]
  109.     set type [set Shel::Type($fileName)]
  110.     # sort out where we're going to put the answer
  111.     set t [getText [pos::math [lineStart $pos] + [expr $ind+2]] [getPos]]
  112.  
  113.     if {[pos::compare [getPos] != [maxPos]]} {
  114.     goto [set pos [maxPos]]
  115.     set ind [string first ${Shel::endPrompt} [getText [lineStart $pos] $pos]]
  116.     if {$ind < 0} {
  117.         insertText "\r" [${type}::Prompt]
  118.     } else {
  119.         set ind [pos::math [lineStart $pos] + [expr $ind +2]]
  120.         if {$ind != $pos} {
  121.         deleteText $ind $pos
  122.         }
  123.     }
  124.     insertText -w $fileName $t
  125.     }
  126.     # carry out the action
  127.     insertText -w $fileName "\r"
  128.     set r [${type}::evaluate $t]
  129.     insertText -w $fileName $r 
  130.     if {$r != ""} { 
  131.     insertText -w $fileName "\r"
  132.     }
  133.     insertText -w $fileName [${type}::Prompt]
  134.     if {[info tclversion] < 8.0} {
  135.     bringToFront $fileName
  136.     goto [getPos -w $fileName]
  137.     } else {
  138.     goto -w $fileName [getPos -w $fileName]
  139.     }
  140. }
  141.  
  142. proc Shel::newPrompt {} {
  143.     global mode histnum Shel::Type Shel::endPrompt
  144.     set fileName [win::CurrentTail]
  145.     set type [set Shel::Type($fileName)]
  146.  
  147.     endOfBuffer
  148.     insertText -w $fileName "\r"
  149.     insertText -w $fileName [${type}::Prompt] 
  150. }
  151.  
  152.  
  153. proc Shel::start {type {title ""} {startuptext ""}} {
  154.     if {$title != ""} {
  155.     if {[lsearch -exact [winNames] $title] != -1} {
  156.         bringToFront $title
  157.         return
  158.     }
  159.     new -n $title -m Shel -shell 1 -text $startuptext
  160.     }
  161.     global Shel::Type
  162.     set c [win::Current]
  163.     set Shel::Type($c) $type
  164.     insertText -w $c [${type}::Prompt]
  165. }
  166.  
  167. # ◊◊◊◊ Alpha shell routines ◊◊◊◊ #
  168.  
  169. proc tclLog {args} {
  170.     catch {eval insertText -w [list "*tcl shell*"] $args}
  171. }
  172.  
  173. proc shell {} {
  174.     Shel::start "Alpha" "*tcl shell*" "Welcome to Alpha's Tcl shell.\r"
  175. }
  176.  
  177. namespace eval Alpha {}
  178.  
  179. proc Alpha::evaluate {t} {
  180.     global errorInfo Shel::histnum
  181.     global Shel::AlphaAlias
  182.     history add $t
  183.     set msg {}
  184.     set lt [expandAliases $t Tcl]
  185.     switch -regexp -- $lt {
  186.     {^\s*alias\s+.*} {
  187.         message "alias to be added"
  188.         if {[llength $lt] != 3} {
  189.         set msg "Error: wrong number of arguments.\rForm is: alias <abrev> <replacement>"
  190.         } else {
  191.         catch {Shel::alias [lindex $lt 1] [lrange $lt 2 2]} msg
  192.         } 
  193.         
  194.     }
  195.     default {
  196.         if {[set code [catch {uplevel \#0 $lt} msg]] == 1} {
  197.         # strip off end of error due to 'uplevel' command
  198.         set new [split $errorInfo \n]
  199.         set new [join [lrange $new 0 [expr [llength $new] - 4]] \n]
  200.         set errorInfo "$new"
  201.         set msg "Error: $msg"
  202.         }
  203.     }
  204.     }
  205.     set Shel::histnum [history nextid]
  206.     return $msg
  207.     
  208. }
  209.  
  210. proc Alpha::Prompt {} {
  211.     global Shel::startPrompt Shel::endPrompt
  212.     return "${Shel::startPrompt}[file tail [string trimright [pwd] {:}]]${Shel::endPrompt} "
  213. }
  214.  
  215. # ◊◊◊◊ MPW routines ◊◊◊◊ #
  216. namespace eval mpw {}
  217. proc mpw::evaluate {t} {
  218.     global Shel::histnum
  219.     history add $t
  220.     set Shel::histnum [history nextid]
  221.     catch {dosc -n ToolServer -s $t} r
  222.     return $r
  223. }
  224. proc mpw::Prompt {} { 
  225.     global Shel::startPrompt Shel::endPrompt
  226.     return "${Shel::startPrompt}mpw${Shel::endPrompt} " 
  227. }
  228.     
  229. proc toolserverShell {} {
  230.     Shel::start "mpw" {*Toolserver shell*} \
  231.       "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents).\r"
  232.     if {[catch {app::ensureRunning MPSX}]} {
  233.     killWindow
  234.     }
  235. }
  236.  
  237. # ◊◊◊◊ Comet routines ◊◊◊◊ #
  238. namespace eval comet {}
  239. proc comet::evaluate {t} {
  240.     cometSendAndPrompt $t
  241.     return ""
  242. }
  243. proc comet::Prompt {} {}
  244.  
  245. # ◊◊◊◊ General purpose ◊◊◊◊ #
  246.  
  247. proc expandAliases {cmdLine {shellType Tcl}} {
  248.     global Shel::AlphaAlias
  249.     if {![info exists Shel::AlphaAlias]} {
  250.     return $cmdLine 
  251.     } 
  252.     while {[string length $cmdLine]} {
  253.     if {[regexp -indices -- \
  254.       {([$]\{?|set\s+)?\b([a-zA-Z_][a-zA-Z_0-9]*)\b(([\.]|(::))[a-zA-Z_0-9]*)*} \
  255.       $cmdLine all dc poss]} {
  256.         if {$all != $poss} {
  257.         set end [lindex $all 1]
  258.         append rtnVal [string range $cmdLine 0 $end]
  259.         set cmdLine [string range $cmdLine [incr end] end]
  260.         } else {
  261.         set start [lindex $poss 0]
  262.         set end [lindex $poss 1]
  263.         if {$start != 0} {
  264.             append rtnVal [string range $cmdLine 0 [expr $start - 1]]                
  265.         } 
  266.         set possAlias [string range $cmdLine $start $end]
  267.         if {[info exists Shel::AlphaAlias($possAlias)]} {
  268.             append rtnVal [set Shel::AlphaAlias($possAlias)] 
  269.         } else {
  270.             append rtnVal [string range $cmdLine $start $end]
  271.         } 
  272.         set cmdLine [string range $cmdLine [incr end] end]
  273.         } 
  274.     } else {
  275.         append rtnVal $cmdLine
  276.         break
  277.     }
  278.     }
  279.     return $rtnVal
  280. }
  281.  
  282. proc Shel::alias {abrev replacement} {
  283.     global Shel::Type
  284.     set fileName [win::CurrentTail]
  285.     set type [set Shel::Type($fileName)]
  286.     
  287.     if {![regexp -- $abrev {[a-zA-Z_][a-zA-Z_0-9]*}]} {
  288.     return "The name used for an alias must start with an alphabetic character \
  289.       \nor an underscore, followed by zero or more characters of the same sort \
  290.       \n(with numbers allowed also)."
  291.     }
  292.     
  293.     if {"[info commands $abrev][procs::find $abrev]" != ""} {
  294.     beep
  295.     if {![string match [askyesno -c "'$abrev' is already a Tcl command, do you wish to Cancel?"] no ] } {
  296.         return "No alias was formed"
  297.     }        
  298.     } 
  299.     
  300.     global Shel::${type}Alias
  301.     if {[info exists Shel::${type}Alias($abrev)]} {
  302.     beep
  303.     if {![string match [askyesno -c "'$abrev' is already an alias for this shell, do you wish to Cancel?" ] no ] } {
  304.         return "No alias was formed"
  305.     } 
  306.     } 
  307.     mode::addUserLine [list set Shel::${type}Alias($abrev) $replacement]
  308.     return "Saved alias in ShellPref.tcl file"
  309. }
  310.  
  311. proc Shel::prevHist {} {
  312.     global Shel::histnum Shel::curCmdLine Shel::endPrompt
  313.     
  314.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  315.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  316.     goto [pos::math [lineStart [getPos]] + $ind + 2]
  317.     } else return
  318.     
  319.     incr Shel::histnum -1
  320.     if {[catch {history event ${Shel::histnum}} text]} {
  321.     incr Shel::histnum
  322.     endOfLine
  323.     beep
  324.     return
  325.     }
  326.     set to [nextLineStart [getPos]]
  327.     if {[is::Eol [lookAt [pos::math $to -1]]]} {set to [pos::math $to -1]}
  328.     if {[expr {${Shel::histnum} + 1}] == [history nextid] } {
  329.     set Shel::curCmdLine [getText [getPos] $to]
  330.     }
  331.     replaceText [getPos] $to $text
  332. }
  333.  
  334.  
  335. proc Shel::nextHist {} {
  336.     global Shel::histnum Shel::curCmdLine Shel::endPrompt
  337.     
  338.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  339.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  340.     goto [pos::math [lineStart [getPos]] + $ind + 2]
  341.     } else return
  342.     
  343.     if {${Shel::histnum} == [history nextid]} {
  344.     beep
  345.     endOfLine
  346.     return
  347.     }
  348.     
  349.     incr Shel::histnum
  350.     if {${Shel::histnum} == [history nextid]} {
  351.     set text ${Shel::curCmdLine}
  352.     } else {
  353.     if {[catch {history event ${Shel::histnum}} text]} {
  354.         endOfLine
  355.         return
  356.     }
  357.     }
  358.     set to [nextLineStart [getPos]]
  359.     if {[is::Eol [lookAt [pos::math $to - 1]]]} {set to [pos::math $to -1]}
  360.     replaceText [getPos] $to $text
  361. }
  362.  
  363. proc Shel::killLine {} {
  364.     global Shel::endPrompt
  365.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  366.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  367.     goto [pos::math [lineStart [getPos]] + [expr {$ind + 2}]]
  368.     } else {
  369.     return
  370.     }
  371.     set to [nextLineStart [getPos]]
  372.     if {[is::Eol [lookAt [pos::math $to - 1]]]} {set to [pos::math $to - 1]}
  373.     deleteText [getPos] $to
  374. }
  375.  
  376. proc Shel::Bol {} {
  377.     global Shel::endPrompt
  378.     set text [getText [lineStart [getPos]] [nextLineStart [getPos]]]
  379.     if {[set ind [string first "${Shel::endPrompt} " $text]] > 0} {
  380.     goto [pos::math [lineStart [getPos]] + [expr {$ind + 2}]]
  381.     } else {
  382.     goto [lineStart [getPos]]
  383.     }
  384. }
  385.  
  386. proc Shel::up {} {
  387.     set pos [pos::math [lineStart [getPos]] - 1]
  388.     if {[catch {regexp {∞} [getText [lineStart $pos] [nextLineStart $pos]]} res] || !$res} {
  389.     previousLine; return
  390.     }
  391.     select [lineStart $pos] [nextLineStart $pos]
  392. }
  393.  
  394. proc Shel::down {} {
  395.     set pos [nextLineStart [getPos]]
  396.     if {[catch {regexp {∞} [getText $pos [nextLineStart $pos]]} res] || !$res} {
  397.     nextLine; return
  398.     }
  399.     select $pos [nextLineStart $pos]
  400. }
  401.  
  402. # ◊◊◊◊ Unix imitation ◊◊◊◊ #
  403.  
  404. proc l {args} {
  405.     eval [concat "ls -CF" $args]
  406. }
  407.  
  408. proc ll {args} {
  409.     eval [concat "ls -l" $args]
  410. }
  411.  
  412.  
  413. proc wc {args} {
  414.     set res {}
  415.     set totChars 0
  416.     set totLines 0
  417.     set totWords 0
  418.     set args [glob -nocomplain $args]
  419.     foreach file $args {
  420.     set id [alphaOpen $file]
  421.     set chars [string length [set text [read $id]]]
  422.     set lines [llength [split $text "\n"]]
  423.     set words [llength [split $text]]
  424.     append res [format "\r%8d%8d%8d    $file" $lines $words $chars]
  425.     set totChars [expr $totChars+$chars]
  426.     set totWords [expr $totWords+$words]
  427.     set totLines [expr $totLines+$lines]
  428.     close $id
  429.     }
  430.     if {[llength $args] > 1} {
  431.     append res [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  432.     }
  433.     return [string range $res 1 end]
  434. }
  435.  
  436.  
  437.  
  438. #================================================================================
  439. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  440. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  441. # assumed to be the parent directory of the top directory we are creating.
  442. #================================================================================
  443. proc cpdir {from to} {
  444.     set cwd [pwd]
  445.     if {[string match ":*" $from] || [string match ":*" $to] ||
  446.     ![file exists $from] || ![file exists $to]} {
  447.     error "'cpdir' args must be complete pathnames of existing folders."
  448.     }
  449.     if {![string match "*:" $from]} {append from ":"}
  450.     if {![string match "*:" $to]} {append to ":"}
  451.     
  452.     if {![file isdirectory $from] || ![file isdirectory $to]} {
  453.     exit 1
  454.     }
  455.     
  456.     set res [catch {cphier $from $to} val]
  457.     cd $cwd
  458.     if {$res} {error $val}
  459. }
  460.  
  461. proc cphier {from to} {
  462.     set savedir [pwd]
  463.     if {[string index $from [expr [string len $from] - 1]] != ":"} {append from ":"}
  464.     set dir [file tail [string trimright $from ":"]]
  465.     cd $to
  466.     mkdir "$dir"
  467.     foreach f [glob "$from*"] {
  468.     if {[file isdirectory $f]} {
  469.         cphier "$f:" "$to$dir:"
  470.     } else {
  471.         cp $f $to$dir:
  472.     }
  473.     }
  474.     cd $savedir
  475. }
  476.  
  477.         
  478. #================================================================================
  479. #####
  480. # (Usage:  'lt' sorts by time, like UNIX's 'ls -lt'.
  481. #          'lt -t' sorts by filename, like UNIX's 'ls -l'.
  482. #          Optionally a directory name can be added as an argument.)
  483.  
  484. proc sortdt {dt} {
  485.     scan $dt "%d/%d/%d {%d:%d:%d %1sM}" mon day yea hou min sec z
  486.     if {$z == "P"} {incr hou 12}
  487.     if {[string length $yea] == 1} {
  488.     set year 200$yea
  489.     } elseif {$yea > 40} {
  490.     set year 19$yea
  491.     } else {
  492.     set year 20$yea
  493.     }
  494.     return [format "%04d%02d%02d%02d%02d" $year $mon $day $hou $min]
  495. }
  496.  
  497.  
  498. #===============================================================================
  499. #####
  500. # (Usage:  'lth' sorts by time, like UNIX's 'ls -lt'.
  501. #          'lth -t' sorts by filename, like UNIX's 'ls -l'.
  502. #
  503. #     Optionally a filename path pattern can be added as an argument.
  504. #       Examples:
  505. #
  506. #           lth :Help:*
  507. #           lth :Help:D*
  508. #           lth HardDisk:news:*
  509. #           lth HardDisk:news:R*
  510. #           lth -t HardDisk:*
  511. #
  512. #       are all good, if you have a volume named "HardDisk" and a
  513. #       folder named "news" on it, but
  514. #       
  515. #           lth Help
  516. #           lth :Help:
  517. #
  518. #       are both bad.
  519. #
  520. #       Use
  521. #       
  522. #           lth {"Macintosh Hd:*"}
  523. #       
  524. #       if you have spaces in the file or folder names.)
  525. #
  526. #    This procedure is based only on the abbreviated format for dates and 
  527. #    time. It does not rely anymore on the short date format which avoids
  528. #    problems such that 'Jan 2' giving either '1/2' (US) or '2/1' (UK).
  529. #    
  530. #    It assumes that :
  531. #    1. dates are coded as a four item list with a four digit field for years
  532. #    and a two digit one for days (plus possible non-digit separators),
  533. #    while weekdays and months are coded with characters in [\w] (plus
  534. #    possible separators in [^\w]);
  535. #    2. day and month fields are consecutive ones and weekday field is before 
  536. #    them when the year field is either the first or the last one;
  537. #    3. time uses 'a' and 'p' in the strings coding twelve hour clocks (case
  538. #    insensitive).
  539. #    
  540. #    This should cover most Mac OS formats for (north) America and Europe
  541. #    ({weekday month day year} or {weekday day month year}), but not
  542. #    non-latin encodings or slavic languages using (for month) characters
  543. #    which are not in the default [\w] set.
  544. #    
  545. #    In (some) Mac OS, the Finnish abbreviated dates use up to six characters.
  546. #    Allowing for month names with up to six characters gives an ugly and
  547. #    confusing result for languages using three (or four) characters, thus
  548. #    the procedure uses only 'ns' characters, where 'ns' is set to 4.
  549. #
  550.  
  551. proc lth args {
  552.     global mode
  553.     
  554.     set date [lindex [mtime [now] a] 0]
  555.     
  556. #
  557. #    Try to find the most likely format for dates.
  558. #
  559.     
  560.     set nmb [regexp "(\[0-9\]+)\[^0-9\]*(\[0-9\]+)" $date t one two]
  561.     if {$nmb != 1} {
  562.     error "Error while scanning the date stamp"
  563.     }
  564.     if {[string length $one] == 4} {
  565.     set year $one
  566.     set day  $two
  567.     } elseif {[string length $two] == 4} {
  568.     set year $two
  569.     set day  $one
  570.     } else {
  571.     error "Error: cannot find the year"
  572.     }
  573.     set i 0
  574.     set indd -1
  575.     set indy -1
  576.     foreach f $date {
  577.     if {[regexp "\[0-9\]+" $f f]} {
  578.         if {$f == $year} {set indy $i}
  579.         if {$f == $day} {set indd $i}
  580.     }
  581.     incr i
  582.     }
  583.     if {($indy == 2) || ($indy == 3)} {
  584.     if {$indd == [expr {$indy - 2}]} {
  585.         set indm [expr {$indy - 1}]
  586.     } elseif {$indd == [expr {$indy - 1}]} {
  587.         set indm [expr {$indy - 2}]
  588.     } else {
  589.         error "Error: date format unknown"
  590.     }
  591.     } elseif {($indy == 0) || ($indy == 1)} {
  592. #
  593. #       If your date format is {year month day weekday} or 
  594. #       {year day month weekday} uncomment the following 'if' 'elseif'
  595. #       'else' block and comment the next one.
  596. #       
  597. #     if {$indd == [expr {$indy + 2}]} {
  598. #         set indm [expr {$indy + 1}]
  599. #     } elseif {$indd == [expr {$indy + 1}]} {
  600. #         set indm [expr {$indy + 2}]
  601. #     } else {
  602. #         error "Error: date format unknown"
  603. #     }
  604. #
  605.     if {$indd == 2} {
  606.         set indm 3
  607.     } elseif {$indd == 3} {
  608.         set indm 2
  609.     } else {
  610.         error "Error: date format unknown"
  611.     }
  612.     } else {
  613.     error "Error: date format unknown"
  614.     }
  615.  
  616. #
  617. #    If you want to set manually the location of the different fields
  618. #    comment (or remove) the lines between the comment
  619. #    "Try to find the most likely format for dates." above and this block 
  620. #    and uncomment the following lines with 'yourXxxField' replaced
  621. #    by a number between 0 and '[llength $date] - 1'.
  622. #    
  623. #    set indd yourDayField
  624. #    set indm yourMonthField
  625. #    set indy yourYearField
  626. #    set year [lindex $date $indy]
  627. #
  628.     
  629.     set val "*"
  630.     set sort 1
  631.  
  632.     foreach arg $args {
  633.     switch -- $arg {
  634.         "-t"    {set sort 0}
  635.         default {set val $arg}
  636.     }
  637.     }
  638.     
  639. #
  640. #    If you want the full Finnish abbreviated form, set 'ns' to 6;
  641. #    if you want only three letters for the month, set 'ns' to 3.
  642. #
  643.     
  644.     set ns 4
  645.     set nsp [expr {$ns + 1}]
  646.     set nf [expr {$ns + 4}]
  647.     set mod ""
  648.     foreach f [eval glob $val] {
  649.     if {[catch {getFileInfo $f info}]} {
  650.         if {$sort} {set mod "            "}
  651.         lappend text [format "%s%s %8d%8d %${nf}s %5s %4s %s %s\n" \
  652.               $mod "D" "0" "0" "" "" "" "DIR " [file tail $f]]
  653.         continue
  654.     }
  655.     if {$sort} {set mod [format "%12u" $info(modified)]}
  656.     set m [mtime $info(modified) a]
  657.     set zer [lindex $m 0]
  658.     regexp "(\[0-9\]+)" [lindex $zer $indd] day
  659.     regexp "(\\w+)" [lindex $zer $indm] month
  660.     set month [string range $month 0 [expr {$ns - 1}]]
  661.     if {$indd < $indm} {
  662.         for {set i [string length $month]} {$i < $ns} {incr i} {
  663.         set month "$month "
  664.         }
  665.         set dat [format "%3s %${ns}s" $day $month]
  666.     } else {
  667.         set dat [format "%${nsp}s %2s" $month $day]
  668.     }
  669.     if {[lindex $zer $indy] == $year} {
  670.         set time [lindex $m 1]
  671.         set nmb [regexp "(\[0-9\]+)(\[^0-9\]+)(\[0-9\]+)" \
  672.              $time t hour sep min]
  673.         if {$nmb != 1} {
  674.         error "Error while scanning the time stamp"
  675.         }
  676.         if {[regexp -nocase "p" $time] && ($hour < 12)} { 
  677.         set hour [expr $hour + 12] 
  678.         }
  679.         if {[regexp -nocase "a" $time] && ($hour == 12)} { 
  680.         set hour [expr $hour - 12] 
  681.         }
  682.         if {[string length $min] == 1} {set min "0$min"}
  683.         set tm "$hour$sep$min"
  684.     } else {
  685.         regexp "(\[0-9\]+)" [lindex $zer $indy] yea
  686.         set tm " $yea"
  687.     }
  688.     lappend text [format "%sF %8d%8d %${nf}s %5s %s %s %s\n" \
  689.               $mod $info(datalen) $info(resourcelen) $dat $tm \
  690.               $info(type) $info(creator) [file tail $f]]
  691.     }
  692.     if {$sort} {
  693.     foreach ln [lsort -de $text] {
  694.         append txt [string range $ln 12 end]
  695.     }
  696.     set ans [string trimright $txt]
  697.     } else {
  698.     set ans [string trimright [join $text {}]]
  699.     }
  700.     
  701.     if { $mode=="Shel" } { 
  702.     return $ans 
  703.     } else {
  704.     new
  705.     insertText $ans "\r"
  706.     catch shrinkHeight
  707.     setWinInfo dirty 0
  708.     setWinInfo read-only 1
  709.     }
  710. }
  711.  
  712.  
  713. #================================================================================
  714. proc ps {} {
  715.     foreach p [processes] {
  716.     append text [format "%-25s %4s %10d %10d\r" [lindex $p 0] [lindex $p 1] [lindex $p 2] [lindex $p 3]]
  717.     }
  718.     return [string trimright $text]
  719. }
  720.  
  721.  
  722. #================================================================================
  723. # Recursively make creator of all text files 'ALFA'. Optionally takes a starting
  724. # dir argument, otherwise starts in current directory. Auto-Doubled are no 
  725. # longer recognized by auto-doubler! Why? Some sort of conflict w/ 'PBSetFInfo'.
  726. proc creator {{dir ":"}}  {
  727.     if {![catch {glob -types TEXT $dir*} files]} {
  728.     foreach f $files {
  729.         file::setSig $f ALFA
  730.     }
  731.     }
  732.     
  733.     if {![catch {glob $dir*} dirs]} {
  734.     foreach d $dirs {
  735.         if {[file isdirectory $d]} {creator $d:}
  736.     }
  737.     }
  738. }
  739.  
  740.  
  741. #===============================================================================
  742.  
  743. proc tomac args {
  744.     set files {}
  745.     foreach arg $args {
  746.     eval lappend files [glob -nocomplain -- $arg]
  747.     }
  748.     set dir [pwd]
  749.     
  750.     foreach f $files {
  751.     message "$f..."
  752.     set fd [open [file join $dir $f] "r"]
  753.     set text [read $fd]
  754.     close $fd
  755.     if {[info tclversion] < 8.0} {
  756.         regsub -all "\n" $text "\r" text
  757.     }
  758.     
  759.     set fd [open [file join $dir $f] "w"]
  760.     puts -nonewline $fd $text
  761.     close $fd
  762.     }
  763.     message ""
  764. }
  765.  
  766.  
  767. #===============================================================================
  768.  
  769. proc unixToMac {fname} {
  770.     set fd [open $fname]
  771.     set text [read $fd]
  772.     close $fd
  773.     set fd [open $fname "w"]
  774.     puts -nonewline $fd $text
  775.     close $fd
  776. }
  777.  
  778. proc setCreator {creator args} {
  779.     set files {}
  780.     foreach arg $args {
  781.     eval lappend files [glob -nocomplain $arg]
  782.     }
  783.     foreach f $files {
  784.     file::setSig $f $creator
  785.     }
  786. }
  787.  
  788. proc setType {type args} {
  789.     set files {}
  790.     foreach arg $args {
  791.     eval lappend files [glob -nocomplain $arg]
  792.     }
  793.     foreach f $files {
  794.     setFileInfo $f type $type
  795.     }
  796. }
  797. #===============================================================================
  798.  
  799. proc pushd {args} {
  800.     global otherDirs
  801.     if {[string length $args]} {
  802.     set otherDirs [concat [list [pwd]] $otherDirs]
  803.     cd [string trim [eval list $args] "        \{\}"]
  804.     } else {
  805.     if {[llength $otherDirs]} {
  806.         set n [lindex $otherDirs 0]
  807.         set otherDirs [concat [list [pwd]] [lrange $otherDirs 1 end]]
  808.         cd $n
  809.     } else {
  810.         return "No other directories"
  811.     }
  812.     }
  813. }
  814. proc pd {args} {
  815.     if {[string length $args]} {
  816.     eval pushd $args
  817.     } else {
  818.     pushd
  819.     }
  820. }
  821.  
  822.  
  823. proc dirs {} {
  824.     global otherDirs
  825.     concat [list [pwd]] [lrange $otherDirs 1 end]
  826. }
  827.  
  828. proc popd {} {
  829.     global otherDirs
  830.     if {[llength $otherDirs]} {
  831.     cd [lindex $otherDirs 0]
  832.     set otherDirs [lrange $otherDirs 1 end]
  833.     } else {
  834.     return "No other directories"
  835.     }
  836. }
  837.  
  838.